;;; ---------------------------------------------------------------
;;;                        -*- GENKIT 4.1 -*-
;;;----------------------------------------------------------------
;;;
;;; COMPGEN.LISP - Generation Grammar Compiler
;;;
;;; Masaru Tomita and Eric Nyberg
;;; Center for Machine Translation
;;; Carnegie Mellon University
;;;
;;; Copyright (c) 1986, 1987, 1988, 1990
;;; All Rights Reserved.
;;;
;;; Last Edit Date: 17-Jul-96 by EHN
;;;
;;; ________________________________________________________________
;;; 
;;; HISTORY
;;; 
;;; 19-Feb-88	Created by Masaru Tomita.
;;;
;;; 03-Nov-88   Koichi Takeda made patches to process-rule so that
;;;             a generated body returns "null" when it failed,
;;;             instead of returning null string. Some debugging
;;;             aids are also embedded in a couple of functions
;;;
;;; 10-Nov-88 by EHN - COMPGEN now takes a second required argument,
;;;             TARGET, which denotes the target language. This symbol
;;;             is used as a prefix on each generator function name.
;;;             The variables storing the generator function name and
;;;             top level function name have been changed slightly
;;;             (see var defs, below, and COMPGEN defun).
;;;
;;; 25-Nov-88 by EHN - now recognizes grammars in the DEFRULE
;;;                    format used by GrETl.
;;;
;;; 29-Mar-90 by EHN - added BLOCK to GENERATOR output code, wrote
;;;                    GENRETURN macro. Changed trace facility.
;;;
;;; 09-Nov-90 by EHN and JRRL - added ==P arrow to grammar, causes
;;;             simple insertion of a path value as the value of the
;;;             non-terminal (see code in PROCESS-RULE).
;;;
;;; 04-Dec-90 by JRRL and EHN - Fixed tracing problem in PROCESS-RULES.
;;;
;;; 07-Dec-90 by JRRL - Got rid of the extra RESULT layer wrapping
;;;                       and made several more subtle changes as well.
;;;
;;; 10-Dec-90 by JRRL - Put the RESULT layer back when tracing is on
;;;                       since you need it then.
;;;                     Made several other cosmetic changes... mostly
;;;                       promoting LET statements.
;;;
;;; 23-Mar-92 by JRRL - Expanded nested backquotes to allow for bugs
;;;                       in new CMU CL and Lucid 4.0.
;;;
;;; 17-Jul-96 by EHN -- General re-write of rule tracing mechanism. 
;;; ________________________________________________________________

;;; ----------------------------------------------------------------
;;;         Global Variables, Parameters, and Constants
;;; ----------------------------------------------------------------

 ; Special strings
 
(defparameter %null-string% "")
(defparameter %blank-space% " ")

 ; Generation Arrow Types.

(defconstant *gen-arrows* '(==p <==> <--> ==> -->))

 ; Constituent list for path names.

(defconstant constit-list 
	'( x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

 ; I/O files and streams.

(defvar *input-gra-file-name*)
(defvar *output-gra-file-name*)
(defvar *output-gra-file-stream*)

 ; RHS Wild-card character (see manual)

(defparameter *wild-card-character* '%)

 ; Prefix for generation functions, default "GG-".
 ;   10-Nov-88 by EHN - two variables, one with the old name.

(defvar *gen-fun-name* "GG-")
(defvar *gen-fun-prefix*)

 ; Top level generation function name, default "GENERATOR".
 ;   10-Nov-88 by EHN - two variables, one with the old name.

(defvar *top-level-gen-fun* "GENERATOR")
(defvar *top-level-gen-fun-name*)

 ; Start Symbol Name, default '<START>

(defparameter *start-symbol* '<start>)

 ; *RULES* is a hash table of rules indexed by lhs

(defvar *rules* (make-hash-table :size 100))

 ; The variable *INITIALIZATIONS* contains a list
 ; of forms to be added at the top of each output file.

(defvar *initializations*)

;;----------------------------------------------------------------------
;; 17-Jul-96 by EHN - CHANGES TO GENKIT TRACE VARIABLES

; OBSOLETE VARIABLES

; ; The variable *ENABLE-TRACING-IN-COMPILER* determines whether or not
; ; the compiler puts in trace code; if NIL, no tracing is built-in and
; ; more efficient code is generated.
;(defvar *enable-tracing-in-compiler* t)
;
; ; The variable *TRACE-RULES* determines what kind of trace information
; ; is printed. It can take the following values:
; ;
; ; 1) :ALL - All rule calls and return values are traced.
; ; 2) :ALL! - All rule calls, input f-structures, and return values are traced.
; ; 3) NIL - no tracing information is output
; ; 4) (:ALL | :ALL! . <list of LHS names> - any rules for constituents of type
; ;    LHS will be traced according to the first element of the list.
; ;
; ; (see macro definition for RULE-TRACE)
;(defvar *trace-rules* nil)
;
; ; The variable *COMPACT-GEN-FILE* indicates whether the output file
; ; should be compacted (not pretty-printed). Default is T; output files
; ; will be compacted by default.
;
;(defvar *compact-gen-file* nil)

; NEW VARIABLES

(defvar *disable-tracing-in-compiler* t 
  "The variable *DISABLE-TRACING-IN-COMPILER* determines whether or
  not the GenKit compiler puts in trace code; if NIL, no tracing is built-in
  and more efficient code is generated. This is set by default, so
  that a typical TL build will generate smaller, faster code and
  compile more quickly."
)

(defvar *genkit-trace-type* 0
  "The type of tracing to use. Possible values:
   0 -- no tracing
   1 -- trace only rules that succeed
   2 -- trace all rules
   3 -- show input/output f-structures for all rules"
)

(defvar *genkit-trace-rules* nil
  "If set, should be a list indicating the specific subset of
   rules to trace (e.g., NP)."
)

(defvar *genkit-pretty-print-rules* nil
  "If set, lisp file produced by COMPGEN will contain pretty-printed
   DEFUNs. Set to NIL by default to produce files that are smaller
   and take less time/space to compile."
)

;; 17-Jul-96 by EHN - END CHANGES TO GENKIT TRACE VARIABLES
;;----------------------------------------------------------------------

 ; The variable *TRACE-RULE-NUMBER* is used internally by the compiler
 ; to number the rules that are processed for each category.

(defvar *trace-rule-number*)

 ; The variable *TRACE-RULE-INDENT* holds the current indent level in
 ; recursive rule invocation (for tracing).

(defvar *trace-rule-indent* 0)

 ; The variable *TRACE-RULE-INDENT-FACTOR* indicates how much the stream
 ; should be indented at each new level of tracing.

(defvar *trace-rule-indent-factor* 2)

 ; The variable *TRACE-RULE-COMPILER* indicates whether the rule compiler
 ; should print trace messages. Should be an INTEGER; 0 means no tracing,
 ; 1 means just file I/O tracing, 2 or higher means show all rule I/O, too.

(defvar *trace-rule-compiler* 1)

 ; The variable *COMPILE-GEN-FILE* indicates that the output file should
 ; be compiled after it is created; default is NIL.

(defvar *compile-gen-file* nil)

;; 17-Jul-96 by EHN It isn't necessary to load the _gen.lisp file if
;; we're going to immediately compile the lisp file during a system
;; build; changed default to nil.

(defvar *load-gen-file* nil)

;; 17-Jul-96 by EHN -- I think this is used to prevent infinite loops
;; in the grammar.

(defvar *genkit-stack* nil)

;;; ----------------------------------------------------------------
;;;                      Tracing Facilities
;;; ----------------------------------------------------------------

(defun quote-list (list)
  (let (result)
    (dolist (item list result)
      (setq result
	    (nconc result
		   (list (list 'quote item)))))))

;;---------------------------------------------------------------------
;; 17-Jul-96 by EHN -- CHANGES TO GENKIT TRACE MACROS.

; OBSOLETE MACROS

;#+:cmu 
;(defmacro gentrace (string &rest args)
;  "Internal trace printer."
;  `(cond (*trace-rules*
;          (format *standard-output* "~%Generator> ")
;          (spaces *trace-rule-indent*)
;          (format *standard-output* ,string ,@args))))
;
;#+:hp
;(defun gentrace (string &rest args)
;  "Internal trace printer."
;  (cond (*trace-rules*
;	 (format *standard-output* "~%Generator> ")
;	 (spaces *trace-rule-indent*)
;	 (eval `(format *standard-output* ,string ,@(quote-list args))))))
;
;
;#-(or :hp :cmu)
;(defmacro gentrace (string &rest args)
;  "Internal trace printer."
;  `(cond (*trace-rules*
;          (format *standard-output* "~%Generator> ")
;          (spaces *trace-rule-indent*)
;          (format *standard-output* ,string ,@args))))
;
;(defmacro trace-rules (spec &rest rules)
;  
;  "SPEC should be NIL, :ALL, :ALL!, or T. If NIL, no trace messages are
;  printed. If :ALL, then rule calls and return values are printed.
;  If :ALL!, then rule calls, f-structures, and return values are
;  printed. RULES, if non-NIL, should be a list of LHS rule names.
;  These rules ONLY will be traced. If NIL, all rules will be traced.
;  If SPEC is T, this is the same as the :ALL case."
;  
;  (cond ((null spec)
;	 `(setq *trace-rules* nil))
;	((member spec '(:all :all!))
;	 (if rules
;	     `(setq *trace-rules* (cons ,spec ',rules))
;	     `(setq *trace-rules* ,spec)))
;	(t `(setq *trace-rules* :all))))

; NEW MACROS

;; GENTRACE is no longer responsible for checking whether it should
;; be called vis a vis trace variables. Calling code should manage
;; this.

(defmacro gentrace (string &rest args)
  `(progn
     (format *standard-output* "~%GenKit> ")
     (spaces *trace-rule-indent*)
     (format *standard-output* ,string ,@args)))

;; GENKIT-TRACING replaces TRACE-RULES.

(defmacro genkit-tracing (type &rest rules)

  "Arglist: (TYPE &REST RULES)

   TYPE should be one of:
   0 -- no tracing
   1 -- trace only successful rules (non-NIL return)
   2 -- trace all rules
   3 -- trace all rules and print f-structures

   RULES should be a list of rule left-hand sides
   that you want to trace.

   Example: (genkit-tracing 1 NP1 ADJP) will trace
   only successful NP! and ADJP rules."

  `(cond ((and (member ,type '(0 1 2 3))
	       (every #'symbolp ',rules))
	  (setq *genkit-trace-type* ,type)
	  (setq *genkit-trace-rules* ',rules))
	 (t (error "GENKIT-TRACING: bad args: ~s ~s"
		   ',type ',rules))))

;; 17-Jul-96 by EHN - END CHANGES TO GENKIT TRACE MACROS
;;----------------------------------------------------------------------

(defmacro comptrace (n string &rest args)
  "Internal trace printer."
  `(cond ((>= *trace-rule-compiler* ,n)
          (format *standard-output* "~%CompGen> ")
          (format *standard-output* ,string ,@args))))

(defun spaces (n &optional (stream *standard-output*))
  (dotimes (x n nil) (write-char #\Space stream)))

;;; ----------------------------------------------------------------
;;;                            Compiler
;;; ----------------------------------------------------------------

(defun compgen (gra-file &optional target)
  
  "GRA-FILE should be the prefix (no .gra extension) of a file
  name containing a grammar. TARGET, if specified, should be a
  symbol denoting the target language (like 'e or 'j)."

  ;;
  ;; Initialize global variables.
  ;;
  
  (cond (target 
	 (setq *gen-fun-prefix*
	       (concatenate 'string
			    (lisp::symbol-name target)
			    "-"
			    *gen-fun-name*))
	 (setq *top-level-gen-fun-name*
	       (intern (concatenate 'string
				    (lisp::symbol-name target)
				    "-"
				    *top-level-gen-fun*)))) 
	(t (setq *gen-fun-prefix* *gen-fun-name*)
	   (setq *top-level-gen-fun-name* (intern *top-level-gen-fun*))))

  (setq *input-gra-file-name*
	(concatenate 'string gra-file ".gra"))

  (setq *output-gra-file-name*
	(concatenate 'string gra-file "_gen.lisp"))

  (setq *output-gra-file-stream*
	(open *output-gra-file-name*
	      :direction :output
	      :if-exists :supersede))

  (setq *initializations* nil)

  (clrhash *rules*)

  ;;
  ;; Read rules into *RULES* table.
  ;;

  (read-gen-rules *input-gra-file-name*)

  ;;
  ;; Add top-level function definitions to *INITIALIZATIONS*.
  ;;
  
  (push `(defun ,*top-level-gen-fun-name* (x)
	   (catch 'generator-return
	     (setq *trace-rule-indent* 0)
	     (setf *genkit-stack* nil)
	     (,(create-f-name *start-symbol*) x)))
	*initializations*)
  
  (push `(defmacro genreturn (value)
	  (list 'throw ''generator-return value))
	*initializations*)

  ;;
  ;; Write output file.
  ;;

  (comptrace 1 "Writing Output File ~s..."  *output-gra-file-name*)

  (force-output)
  
  (dolist (statement *initializations*)
    (let ((*print-pretty* *genkit-pretty-print-rules*)
	  (*print-length* nil)
	  (*print-level* nil)
	  (*print-circle* nil))
      (print statement *output-gra-file-stream*)
      (if *print-pretty* (terpri *output-gra-file-stream*))))

  (maphash #'process-rules *rules*)

  (close *output-gra-file-stream*)

  (comptrace 1 "Output File Written: ~s" *output-gra-file-name*)

  ;;
  ;; (Possibly) Compile and/or Load output file back into Lisp.
  ;;

  (when *compile-gen-file*
	 (comptrace 1 "Compiling Output File ~s..." *output-gra-file-name*)
	 (force-output)
	 (compile-file *output-gra-file-name*)
	 (comptrace 1 "Done Compiling Output File.")
	 (force-output))

  (when *load-gen-file*
	 (let ((f (if *compile-gen-file*
		      (concatenate 'string gra-file "_gen.fasl")
		      *output-gra-file-name*)))
           (comptrace 1 "Loading Output File ~s..." f)
	   (force-output)
  	   (load f)
	   (comptrace 1 "Done Loading Output File.")
	   (force-output)))

  (comptrace 1 "Done.")

  ;;
  ;; Return the output file name.
  ;;
  
  *output-gra-file-name*)

;;; ----------------------------------------------------------------
;;;                      Rule Pre-Processor.
;;; ----------------------------------------------------------------

(defun gen-rule-preprocess (rule)
  (let ((head (first rule))
	(arrow (second rule)))
    (cond
     ((member head '(defmacro defun))
      (eval rule) ;;;;;; DONT UNDERSTAND THIS --- DONT COPY TO FILE?
      nil)
     ((member head '(@lex '@gra))
      (push `(load-gen-files
	      ',(mapcar (function prin1-to-string) (rest rule)))
	    *initializations*)
      nil)
     ((macro-function head)
      (mapcan #'gen-rule-preprocess (macroexpand rule)))
     ((member arrow *gen-arrows*)
      rule)
     (t (format *standard-output*
	  "~%~%*** Possible Problem: strange arrow ~a in rule ~a ~%" arrow rule)
      nil)))) ;;; IGNORE? maybe we should print a message.
  
(defun load-gen-files (file-list)
  (dolist (file file-list)
    (load (concatenate 'string file "_gen.lisp"))))
  
(defun read-gen-rules (file)
  (comptrace 1 "Reading grammar file ~s..." *input-gra-file-name*)
  (force-output)
  (with-open-file (ifile file :direction :input)
    (do ((rule (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq rule '%eof%))
      (comptrace 2 "Reading ~a" (car rule))
      (setq rule (gen-rule-preprocess rule))
      (when rule
	(push rule (gethash (car rule) *rules*))))
    (comptrace 1 "Done Reading grammar file.")))

;;----------------------------------------------------------------------
;; 17-Jul-96 by EHN -- CHANGES TO GENKIT TRACING FUNCTIONS

; OBSOLETE CODE

;(defun rule-call-trace-form (fn constit fs)
;  (and *trace-rules*
;       (cond ((and (listp *trace-rules*)
;		   (member constit (rest *trace-rules*)))
;	      (case (first *trace-rules*)
;		(:all! (gentrace "~a called with ~a" constit fs))
;		(:all  (gentrace "~a called" constit))
;		(t nil)))
;	     ((symbolp *trace-rules*)
;	      (case *trace-rules*
;		(:all! (gentrace "~a called with ~a" constit fs))
;		(:all  (gentrace "~a called" constit))
;		(t nil))))))
;
;(defun rule-return-trace-form (fn constit result)
;  (and *trace-rules*
;       (cond ((and (listp *trace-rules*)
;		   (member constit (rest *trace-rules*)))
;	      (case (first *trace-rules*)
;		((:all! :all)
;                 (gentrace "~a returns ~s" constit result))
;		(t nil)))
;	     ((symbolp *trace-rules*)
;	      (case *trace-rules*
;		((:all! :all)
;		 (gentrace "~a returns ~s" constit result))
;		(t nil))))))

; NEW FUNCTIONS

(defun trace-genkit-nterm-result (fn constit result)
  (when
   (and (> *genkit-trace-type* 0)
	(if *genkit-trace-rules*
	    (member constit *genkit-trace-rules*)
	  t)
	(if (< *genkit-trace-type* 2)
	    result
	  t))
   (gentrace "~a returns ~s" constit result)))

(defun trace-genkit-nterm (fn constit fs)
  (when
   (and (> *genkit-trace-type* 0)
	(if *genkit-trace-rules*
	    (member constit *genkit-trace-rules*)
	  t))
   (if (> *genkit-trace-type* 2)
       (gentrace "~a called with ~a" constit fs)
     (gentrace "~a called" constit))))
   
;; 17-Jul-96 by EHN -- END CHANGES TO GENKIT TRACE FUNCTIONS
;;----------------------------------------------------------------------


;;;------------------------------------------------------------------;
;;; PROCESS-RULES                                                    ;
;;;                                                                  ;
;;; Calls process-rule on each rhs and bundles them up into lhs      ;
;;; functions.                                                       ;
;;;                                                                  ;
;;; Resulting functions are printed to *output-gra-file-stream*.     ;

(defun process-rules (lhs rules)
  (comptrace 2 "Processing rules for ~a" lhs)
  (setq *trace-rule-number* 0)
  (let* ((func-name (create-f-name (symbol-name lhs)))
	 (func-body
	  (if ;; 17-Jul-96 by EHN
	      (not *disable-tracing-in-compiler*)
	      `(defun ,func-name (x0)
		 (unless (member (cons ',func-name x0) *genkit-stack*
				 :test #'equalp)
		   (push (cons ',func-name x0) *genkit-stack*)
		   (let (x result result-string temp)
		     ;; 17-Jul-96 by EHN
		     (trace-genkit-nterm ',func-name ',lhs x0)		     
		     (setq *trace-rule-indent*
			   (+ *trace-rule-indent* 
			      *trace-rule-indent-factor*))
		     (setq result
			   (or ,@(map-dolist (rule (reverse rules))
					     (process-rule rule))))
		     (setq *trace-rule-indent*
			   (- *trace-rule-indent* 
			      *trace-rule-indent-factor*))
		     (pop *genkit-stack*)
		     ;; 17-Jul-96 by EHN
		     (trace-genkit-nterm-result ',func-name ',lhs result)
		     result)))
	      `(defun ,func-name (x0)
		 (let (x result-string temp)
		   (or ,@(map-dolist (rule (reverse rules))
			   (process-rule rule))))))))
    ;func-body
    (let ((*print-pretty* *genkit-pretty-print-rules*)
	  (*print-level* nil)
	  (*print-length* nil)
	  (*print-circle* nil))
      (print func-body *output-gra-file-stream*)
      (if *print-pretty* (terpri *output-gra-file-stream*)))))


;;;------------------------------------------------------------------;
;;; TRACE-RULE-CALL                                                  ;
;;;                                                                  ;
;;; Venerable (from Tomita himself) tracing macro                    ;

;; 17-Jul-96 by EHN -- UPDATED

(defmacro trace-rule-call (cat number form)
  `(let ((result ,form))
     (when
      (and (> *genkit-trace-type* 0)
	   (if *genkit-trace-rules*
	       (member ',cat *genkit-trace-rules*)
	     t)
	   (if (< *genkit-trace-type* 2)
	       result
	     t))
      (gentrace "Rule ~a for ~a returns ~s" 
		,number ',cat result))
     result))

;;;------------------------------------------------------------------;
;;; PROCESS-RULE                                                     ;
;;;                                                                  ;
;;; Handled one rhs.  For each case, it just sets up x0 and calls    ;
;;; the specific sub-code-generation routine.                        ;
;;;                                                                  ;
;;; Note: this is where ehn and jrrl hacked in ==p.                  ;

(defun process-rule (rule)
  (let ((lhs (first rule))
	(arrow (second rule))
	(rhs-list (third rule))
	(statements (fourth rule)))
    (if (eq arrow '==p) ;; 09-Nov-90 by EHN and JRRL -- New arrow type to
  	                ;; replace simple lexical insertion of a path.
	
	(if ;; 17-Jul-96 by EHN
	    (not *disable-tracing-in-compiler*)
	    `(trace-rule-call ,lhs ,(incf *trace-rule-number*)
	       (progn
		 (setq x (list (list 'x0 x0))) ;`((x0 ,x0)))		   
		 (make-it-string (getvalue x ',(third rule)))))
	    `(progn
	       (setq x (list (list 'x0 x0))) ;`((x0 ,x0)))  
	       (make-it-string (getvalue x ',(third rule)))))
	
	(if ;; 17-Jul-96 by EHN
	    (not *disable-tracing-in-compiler*)
	    `(trace-rule-call ,lhs ,(incf *trace-rule-number*)
	       (progn
		 (setq x (list (list (list 'x0 x0)))) ; `(((x0 ,x0))))
		 (and
		  ,@(cdr (compile-statements statements))
		  (or-dolist (fs x)
		    (progn
		      (setq result-string ,%null-string%)
		      ,(rhs-funcalls rhs-list arrow)
		      (if (zerop (length result-string)) nil result-string))))))
	    `(progn
	       (setq x (list (list (list 'x0 x0)))) ; `(((x0 ,x0))))
	       (and
		,@(cdr (compile-statements statements))
		(or-dolist (fs x)
		  (progn
		    (setq result-string ,%null-string%)
		    ,(rhs-funcalls rhs-list arrow)
		    (if (zerop (length result-string)) nil result-string)))))))))


;;;------------------------------------------------------------------;
;;; BUILD-TERMINAL-STRING                                            ;
;;;                                                                  ;
;;; Produces a single string for simple rhs.                         ;

(defun build-terminal-string (rhs-terminals arrow)
  (let ((padchar (decide-word-boundary-2 arrow))
	(result ""))
    (dolist (terminal rhs-terminals)
      (setq result
	    (concatenate 'string result (make-it-string terminal) padchar)))
    `(setq result-string ,(format nil "~a" result))))


;;;------------------------------------------------------------------;
;;; RHS-FUNCALLS                                                     ;
;;;                                                                  ;
;;; Calls RHS-FUNCALL for non-terminal rhs and builds a terminal     ;
;;; string for others.                                               ;

(defun rhs-funcalls (rhs-list arrow)     ;; 01-Apr-90 by EHN - better generated
  (if (every #'(lambda (x)               ;; code for lexical rules.  
		 (and (not (non-term x)) 
		      (not (eq x *wild-card-character*))))
	     rhs-list)
      (build-terminal-string rhs-list arrow)
      (let ((funcalls nil)
	    (word-boundary ""))
	(dotimes (i (length rhs-list) (cons 'and funcalls))
	  (setq word-boundary 
		(if (= i 0) %null-string% (decide-word-boundary arrow)))
	  (setq funcalls
		(append funcalls
			(list (rhs-funcall (nth i rhs-list)
					   (nth (1+ i) constit-list)
					   word-boundary))))))))


;;;------------------------------------------------------------------;
;;; RHS-FUNCALL                                                      ;
;;;                                                                  ;
;;; Venerable Tomita code for building recursing string building     ;
;;; code.                                                            ;

(defun rhs-funcall (rhs xn word-boundary)
  (cond
   ((non-term rhs)
    `(progn
       (setq temp (,(create-f-name rhs) (getvalue fs '(,xn))))
       (if temp (setq result-string
		      (concatenate 'string
				   result-string ,word-boundary temp))
	   (progn (setq result-string "") nil))))
   ((eq rhs *wild-card-character*)
    `(setq result-string
	   (concatenate 'string
			result-string
			,word-boundary
			(make-it-string (getvalue fs '(,xn value))))))
   ((member rhs '(\: \; \. \" \\ \' \( \) \!))
    `(setq result-string
	   (concatenate 'string
			result-string ,word-boundary
			(symbol-name ,(concatenate 'string "'\\"
						   (symbol-name rhs))))))
   (t
    `(setq result-string
	   (concatenate 'string
			result-string ,word-boundary (make-it-string ',rhs))))))


(defun make-it-string (x)
	(if (symbolp x) (symbol-name x)
	    (if (numberp x) (prin1-to-string x) x)))

(defun create-f-name (lhs)
  (intern
   (concatenate 'string *GEN-FUN-PREFIX*
		(string-trim '(#\< #\>) lhs))))

(defun decide-word-boundary (arrow)
     (case arrow
       ((<==> ==>) %blank-space%)
       ((<--> -->) %null-string%)))

(defun decide-word-boundary-2 (arrow)
     (case arrow
       ((<==> ==>) " ")
       ((<--> -->) "")
       (t (error "Bad arrow type: ~a" arrow))))

(defun non-term (s)
  (cond ((numberp s) nil)
        (t (and (atom s) (equal #\< (elt (symbol-name s) 0))))))

(defun registerp (object)
  (member object constit-list :test #'eq))

(defun tr (string)
  (let ((*parse-return-value* t))
    (generator (cons '*OR* (parse string)))))

